Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d18/facilis2.arc/BLOCK.PAS

Pascal/Delphi Source File | 1991-04-28 | 44KB | 1,500 lines

{ Facilis 0.31                                   file: BLOCK.PAS      }

overlay procedure blockov(fsys: symset; isfun: boolean; level: integer);

type   item = record
                typ: types; ref: index; temp: boolean
              end;
     conrec = record case tp: types of
                       ints,chars,bools: (i:integer);
                       reals: (r: real)
                     end ;

var    dx : integer;    { data allocation index }
       prt: integer;    { t-index of this procedure }
       prb: integer;    { b-index of this procedure }
       x  : integer;

  procedure skip(fsys: symset; n: integer);

  begin
    error(n); skipflag := true;
    while not (sy in fsys) do insymbol;
    if skipflag then endskip
  end  { skip } ;

  procedure test(s1,s2: symset; n: integer);

  begin
    if not (sy in s1) then skip(s1+s2,n)
  end  {test } ;

  procedure testsemicolon;

  begin
    if sy = semicolon
    then insymbol
    else begin
      error(14);
      if sy in [comma,colon] then insymbol
    end ;
    test([ident]+blockbegsys, fsys, 6)
  end  { testsemicolon } ;

  procedure enter(id: alfa; k:object);

  var    j,l: integer;
  begin
    if t = tmax
    then fatal(1)
    else begin
      tab[0].name := id;
      j := btab[display[level]].last;  l := j;
      while tab[j].name <> id do  j := tab[j].link;
      if j <> 0
      then error(1)
      else begin
        t := t+1;
        with tab[t] do
        begin
          name:= id;   link := l;
          obj := k;     typ := notyp;   ref := 0;
          lev := level; adr := 0
        end ;
        btab[display[level]].last := t
      end
    end
  end  { enter } ;

  function loc(id: alfa): integer;

  var    i,j: integer;      { locate id in tabel }
  begin
    i := level; tab[0].name := id;    { sentinel }
    repeat
      j := btab[display[i]].last;
      while tab[j].name <> id do  j := tab[j].link;
      i := i-1;
    until (i<0) or (j<>0);
    if j = 0 then error(0);
    loc := j
  end  { loc } ;

  procedure entervariable;

  begin
    if sy = ident
    then begin
      enter(id,vvariable); insymbol
    end else error(2)
  end  { entervariable } ;

  procedure constant(fsys: symset; var c: conrec);

  var    x, sign: integer;
  begin
    c.tp := notyp; c.i := 0;
    test(constbegsys, fsys, 50);
    if sy in constbegsys
    then begin
      if sy = charcon
      then begin
        c.tp := chars; c.i := inum;
        insymbol
      end else
      if sy = stringcon
      then begin
        c.tp := strngs;
        c.i := seg(spnt^);
        insymbol
      end else begin
        sign := 0;
        if sy in [plus,minus]
        then begin
          if sy = minus then sign := -1 else sign := 1;
          insymbol
        end ;
        if sy = ident
        then begin
          x := loc(id);
          if x <> 0
          then if tab[x].obj <> konstant
               then error(25)
               else begin
                 c.tp := tab[x].typ;
                 if c.tp in [ints,reals] then
                   if sign=0 then sign := 1;
                 if c.tp = reals
                 then c.r := sign*rconst[tab[x].adr]
                 else if c.tp = ints
                 then c.i := sign*tab[x].adr
                 else begin
                   if sign<>0 then error(33);
                   c.i := tab[x].adr
                 end
               end ;
          insymbol
        end else begin
          if sign=0 then sign := 1;
          if sy = intcon
            then begin
              c.tp := ints; c.i := sign*inum;
              insymbol
            end else if sy = realcon
                     then begin
                       c.tp := reals; c.r := sign*rnum;
                       insymbol
                     end else skip(fsys,50)
        end
      end;
      test(fsys,[], 6)
    end
  end  { constant } ;

  procedure typ(fsys: symset; var tp: types; var rf, sz: integer);

  var    eltp: types;
         elrf,elsz,offset,x,t0,t1: integer;
        dummy: conrec;

    procedure arraytyp(var aref,arsz: integer);

    var    eltp: types;
           low, high: conrec;
           elrf, elsz: integer;
    begin
      constant([twodots,rbrack,rparent,ofsy]+fsys, low);
      if low.tp in [reals,strngs]
      then  begin
        error(27);
        low.tp := ints; low.i := 0
      end ;
      if sy = twodots then insymbol else error(13);
      constant([rbrack,comma,rparent,ofsy]+fsys, high);
      if high.tp <> low.tp
      then begin
        error(27); high.i := low.i
      end ;
      enterarray(low.tp, low.i,high.i);
      aref := a;
      if sy = comma
      then begin
        insymbol;
        eltp := arrays;
        arraytyp(elrf,elsz)
      end else begin
        if sy = rbrack
        then insymbol
        else begin
          error(12);
          if sy = rparent then insymbol
        end ;
        if sy = ofsy then insymbol else error(8);
        typ(fsys,eltp,elrf,elsz)
      end ;

      with atab[aref] do
      begin
        arsz := (high-low+1)*elsz; size := arsz;
        if arsz > stacksize then error(61);
        eltyp := eltp; elref := elrf; elsize := elsz
      end ;
    end  {arraytyp } ;

  begin  { typ }
    tp := notyp; rf := 0; sz := 0;
    if sy = packedsy
    then begin
      insymbol;
      if not (sy = arraysy) or (sy = recordsy)
      then error(10);
    end;
    test(typebegsys,fsys, 10);
    if sy in typebegsys
    then begin
      if sy = ident
      then begin
        x := loc(id);
        if x <> 0
        then with tab[x] do
               if obj <> type1
               then error(29)
               else begin
                 tp := typ; rf := ref; sz := adr;
                 if tp = notyp then error(30)
               end ;
        insymbol;
        if (tp=strngs) and (sy=lbrack)
        then begin
          insymbol;
          constant([rbrack]+fsys,dummy);
          if sy=rbrack then insymbol else error(12);
        end;
      end else if sy = arraysy
               then begin
                 insymbol;
                 if sy = lbrack
                 then insymbol
                 else begin
                   error(11);
                   if sy = lparent
                   then insymbol
                 end ;
                 tp := arrays; arraytyp(rf,sz)
               end else begin  { records }
                 insymbol;
                 enterblock;
                 tp := records; rf := b;
                 if level = lmax then fatal(5);
                 level := level+1; display[level] := b; offset := 0;
                 while not (sy in fsys-[semicolon,comma,ident]+[endsy]) do
                 begin  { field section }
                   if sy = ident
                   then begin
                     t0 := t; entervariable;
                     while sy = comma do
                     begin
                       insymbol; entervariable;
                     end ;
                     if sy = colon then insymbol else error(5);
                     t1 := t;
                     typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz);
                     while t0 < t1 do
                     begin
                       t0 := t0+1;
                       with tab[t0] do
                       begin
                         typ := eltp;
                         ref := elrf;   normal := true;
                         adr := offset; offset := offset + elsz
                       end
                     end
                   end ; {sy = ident}
                   if sy <> endsy
                   then begin
                     if sy = semicolon
                     then insymbol
                     else begin
                       error(14);
                       if sy = comma then insymbol
                     end ;
                     test([ident,endsy,semicolon], fsys, 6)
                   end
                 end ; {field section}

                 btab[rf].vsize := offset; sz := offset;
                 if sz > stacksize then error(61);
                 btab[rf].psize := 0;
                 insymbol; level := level-1
               end ; {records}
      test(fsys, [], 6)
    end
  end  { typ } ;

  procedure parameterlist;      { formal parameter list }

  var    tp    : types;
         valpar: boolean;
         rf,sz, x, t0: integer;
  begin
    insymbol;
    tp := notyp; rf := 0; sz := 0;
    test([ident, varsy], fsys+[rparent], 7);
    while sy in [ident, varsy] do
    begin
      if sy <> varsy
      then valpar := true
      else begin
        insymbol;
        valpar := false
      end ;
      t0 := t; entervariable;
      while sy = comma do
      begin
        insymbol; entervariable;
      end;
      if sy = colon
      then begin
        insymbol;
        if sy <> ident
        then error(2)
        else begin
          x := loc(id); insymbol;
          if x <> 0
          then with tab[x] do
               if obj <> type1
               then error(29)
               else begin
                 tp := typ;   rf := ref;
                 if valpar then sz := adr else sz := 1
               end ;
          end ;
        test([semicolon,rparent], [comma,ident]+fsys, 14)
      end else error(5);
      while t0 < t do
      begin
        t0 := t0+1;
        with tab[t0] do
        begin
          typ := tp; ref := rf;
          adr := dx; lev := level;
          normal := valpar;
          dx := dx + sz
        end
      end ;
      if sy <> rparent
      then begin
        if sy = semicolon
        then insymbol
        else begin
          error(14);
          if sy = comma then insymbol
        end ;
        test([ident,varsy], [rparent]+fsys, 6)
      end
    end  { while } ;

    if sy = rparent
    then begin
      insymbol;
      test([semicolon,colon], fsys, 6)
    end else error(4)
  end  { parameterlist } ;

  procedure     constdec;

  var    c: conrec;
  begin
    insymbol;
    test([ident], blockbegsys, 2);
    while sy = ident do
    begin
      enter(id,konstant); insymbol;
      if sy = eql
      then insymbol
      else begin
        error(16);
        if sy = becomes then insymbol
      end ;
      constant([semicolon,comma,ident]+fsys,c);
      tab[t].typ := c.tp;
      tab[t].ref := 0;
      if c.tp = reals
      then begin
        enterreal(c.r); tab[t].adr := c1
      end else tab[t].adr := c.i;
      testsemicolon
    end
  end  { constdec } ;

  procedure typedeclaration;

  var    tp: types;
         rf, sz, t1: integer;
  begin
    insymbol;
    test([ident], blockbegsys, 2);
    while sy = ident do
    begin
      enter(id,type1);
      t1 := t; insymbol;
      if sy = eql
      then insymbol
      else begin
        error(16);
        if sy = becomes then insymbol
      end ;
      typ([semicolon,comma,ident]+fsys, tp, rf, sz);
      with tab[t1] do
      begin
        typ := tp; ref := rf; adr := sz
      end;
      testsemicolon
    end
  end  { typedeclaration } ;

  procedure variabledeclaration;

  var    tp: types;
         t0, t1, rf, sz: integer;
  begin
    insymbol;
    while sy = ident do
    begin
      t0 := t; entervariable;
      while sy = comma do
      begin
        insymbol; entervariable;
      end ;
      if sy = colon then insymbol else error(5);
      t1 := t;
      typ([semicolon,comma,ident]+fsys, tp, rf, sz);
      while t0 < t1 do
      begin
        t0 := t0+1;
        with tab[t0] do
        begin
          typ := tp;    ref := rf;
          lev := level; adr := dx;
          normal := true;
          dx := dx + sz
        end
      end ;
      testsemicolon
    end
  end  { variabledeclaration } ;

  procedure procdeclaration;

  var    isfun: boolean;
  begin
    isfun := sy = funcsy;
    insymbol;
    if sy <> ident
    then begin
      error(2); id := '          '
    end;
    if isfun then enter(id,funktion) else enter(id,prozedure);
    tab[t].normal := true;
    insymbol;
    block([semicolon]+fsys, isfun, level+1);
    if sy = semicolon then insymbol else error(14);
    emit(132+ord(isfun))     { exit }
  end  { procdeclaration } ;

  procedure statement(fsys: symset);

  var    i: integer;
         x: item;

    procedure expression(fsys: symset; var x: item); forward;

    procedure selector(fsys: symset; var v: item);

    var    x: item;
           a,j: integer;
    begin  { sy in [lparent, lbrack, period] }
      repeat
        if sy = period
        then begin
          insymbol;   { field selector }
          if sy <> ident
          then error(2)
          else begin
            if v.typ <> records
            then error(31)
            else begin  {search field identifier }
              j := btab[v.ref].last;
              tab[0].name := id;
              while tab[j].name <> id do j := tab[j].link;
              if j = 0 then error(0);
              v.typ := tab[j].typ;
              v.ref := tab[j].ref;
              a := tab[j].adr;
              if a <> 0 then emit1(9,a)
            end ;
            insymbol
          end
        end else begin  { array selector }
          if sy <> lbrack then error(11);
          if v.typ=strngs then begin
            insymbol;
            expression(fsys+[rbrack],x);
            if x.typ<>ints then error(34) else emit(165);
            v.typ := chars
          end else
          repeat
            insymbol;
            expression(fsys+[comma,rbrack], x);
            if v.typ <> arrays
            then error(28)
            else begin
              a := v.ref;
              if atab[a].inxtyp <> x.typ
              then error(26)
              else if atab[a].elsize = 1
                   then emit1(20,a)
                   else emit1(21,a);
              v.typ := atab[a].eltyp;
              v.ref := atab[a].elref
            end
          until sy <> comma;

          if sy = rbrack
          then insymbol
          else begin
            error(12);
            if sy = rparent then insymbol
          end
        end
      until not (sy in [lbrack,lparent,period]);

      test (fsys, [], 6)
    end  { selector } ;

    procedure call(fsys: symset; i: integer);

    var    x: item;
           lastp, cp, k: integer;

    begin
      emit1(18,i);   { mark stack }
      lastp := btab[tab[i].ref].lastpar;
      cp := i;
      if sy = lparent
      then begin  { actual parameter list }
        repeat
          insymbol;
          if cp >= lastp
          then error(39)
          else begin
            cp := cp+1;
            if tab[cp].normal
            then begin  {value parameter }
              expression(fsys+[comma,colon,rparent], x);
              if x.typ=tab[cp].typ
              then begin
                if x.ref <> tab[cp].ref
                then error(36)
                else if x.typ = arrays
                     then emit1(22,atab[x.ref].size)
                else if x.typ = records
                     then emit1(22,btab[x.ref].vsize)
                else if x.typ = strngs
                     then if x.temp then emit(173)
                                    else emit(172)
              end else if (x.typ=ints) and (tab[cp].typ=reals)
                       then emit1(26,0)
                       else if x.typ<>notyp then error(36);
            end else begin  { var parameter }
              if sy <> ident
              then error(2)
              else begin
                k := loc(id);
                insymbol;
                if k <> 0
                then begin
                  if tab[k].obj <> vvariable then error(37);
                  x.typ := tab[k].typ;
                  x.ref := tab[k].ref;
                  if tab[k].normal
                  then emit2(0,tab[k].lev,tab[k].adr)
                  else emit2(1,tab[k].lev,tab[k].adr);
                  if sy in [lbrack,lparent,period]
                  then begin
                    if x.typ=strngs then error(60);
                    selector(fsys+[comma,colon,rparent], x);
                  end;
                  if (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref)
                  then error(36)
                end
              end
            end {var parameter}
          end ;
          test([comma,rparent], fsys, 6)
        until sy <> comma;

        if sy = rparent then insymbol else error(4)
      end ;

      if cp < lastp then error(39);  { too few actual parameters }
      emit1(19, btab[tab[i].ref].psize-1);
      if tab[i].lev < level then emit2(3, tab[i].lev, level)
    end  { call } ;

    function resulttype(a,b: types): types;

    begin
      if (a>reals) or (b>reals)
      then begin
        error(33);
        resulttype := notyp
      end else if (a=notyp) or (b=notyp)
               then resulttype := notyp
               else if a=ints
                    then if b=ints
                         then resulttype := ints
                         else begin
                           resulttype := reals; emit1(26,1)
                         end
                    else begin
                      resulttype := reals;
                      if b=ints then emit1(26,0)
                    end
    end   { resulttype } ;

    procedure expression {fsys:symset; var x:item};

    var    y :item;
           op:symbol;
           t :integer;

      procedure simpleexpression(fsys:symset; var x:item);

      var    y :item;
             op:symbol;
             t :integer;

        procedure term(fsys:symset; var x:item);

        var    y :item;
               op:symbol;
               ts:typset;

          procedure factor(fsys:symset; var x:item);

          var    i,f: integer;

            procedure standfct(n: integer);

            var    ts: typset;

            begin { standard function no. n }
            if n in [19,39,47,48,49]
{ maxavail,keypressed,inkey,wherex,wherey }
            then emit1(8,n)
{ random }  else if (n=40) and (sy <> lparent)
                 then begin
                   emit1(8,n+1);
                   x.typ := reals; end
            else begin
              if sy = lparent
              then insymbol
              else error(9);
              if (n < 17) or (n > 19)
              then begin
                expression(fsys+[comma,rparent],x);

                case n of

 { abs,sqr }    0,2: begin
                       ts := [ints,reals];
                       tab[i].typ := x.typ;
                       if x.typ = reals then n := n+1
                     end;

 { odd,chr }    4,5: ts := [ints];

 { ord }          6: ts := [ints,bools,chars];

 { succ,pred }  7,8: begin
                       ts := [ints,bools,chars];
                       tab[i].typ := x.typ
                     end;

 { round,trunc } 9,10,11,12,13,14,15,16:
 { sin,cos,... }     begin
                       ts := [ints,reals];
                       if x.typ = ints then emit1(26,0)
                     end;

 { length }      20: begin
                       ts := [strngs,chars];
                       if x.temp then n := n+1;
                       if x.typ = chars then n := n+2
                     end;

 { copy }        23: begin
                       ts := [strngs,chars];
                       if x.typ = chars then n := n+2
                         else if x.temp then n := n+1;
                       test([comma], [comma,rparent]+fsys, 59);
                       if sy = comma then begin
                         insymbol;
                         expression(fsys+[comma,rparent],y);
                         if y.typ <> ints
                           then if y.typ <> notyp then error(34);
                         test([comma,rparent], fsys, 6);
                         if sy = comma then begin
                           insymbol;
                           expression(fsys+[rparent],y);
                           if y.typ <> ints
                             then if y.typ <> notyp then error(34);
                         end else emit1(24,nmax);
                       end;
                     end;

{ pos }          26: begin
                       ts := [strngs,chars];
                       if x.typ = chars then n := n+2
                         else if x.temp then n := n+1;
                       test([comma], [comma]+fsys, 59);
                       if sy = comma then begin
                         insymbol;
                         expression(fsys+[rparent],y);
                         if y.typ <> strngs
                         then if y.typ <> notyp then error(38) else
                         else if y.temp then n := n+4;
                       end
                     end;

{ str }          33: begin
                       ts := [ints,reals];
                       if x.typ = reals then n := n+1
                     end;

{ val,rval }  35,37: begin
                       ts := [strngs];
                       if x.temp then n := n+1
                     end;

{ random }       40: ts := [ints];

{ upcase }       42: ts := [chars];

                end ; { case }

                if x.typ in ts
                then emit1(8,n)
                else if x.typ <> notyp
                     then error(48);
              end else begin    { n in [17,18] }
                if sy <> ident
                then error(2)
                else if id <> 'input     '
                     then error(0)
                     else insymbol;
                emit1(8,n);
              end ;
              x.typ := tab[i].typ; x.temp := true;
              if sy = rparent then insymbol else error(4)
            end end { standfct } ;

          begin  { factor }
            x.typ := notyp;
            x.ref := 0;
            test(facbegsys, fsys, 58);
            while sy in facbegsys do begin
            case sy of
       ident: begin
                i := loc(id);
                insymbol;
                with tab[i] do

                  case obj of

          konstant: begin
                      x.typ := typ;
                      x.ref := 0; x.temp := false;
                      if x.typ = reals
                      then emit1(25,adr)
                      else emit1(24,adr)
                    end ;

         vvariable: begin
                      x.typ := typ;
                      x.ref := ref; x.temp := false;
                      if sy in [lbrack,lparent,period]
                      then begin
                        if normal then f := 0 else f := 1;
                        if x.typ=strngs then begin
                          emit2(f+1,lev,adr);
                          selector(fsys,x);  end
                        else begin
                          emit2(f,lev,adr);
                          selector(fsys,x);
                          if x.typ in stantyps then emit(134);
                        end
                      end else begin
                        if x.typ in stantyps
                        then if normal
                             then f := 1
                             else f := 2
                        else if normal then f := 0 else f :=1;
                        emit2(f, lev, adr)
                      end
                    end ;

  type1, prozedure: error(44);

         funktion : begin
                      x.typ := typ; x.temp := true;
                      if lev <> 0
                      then call(fsys, i)
                      else standfct(adr)
                    end

                  end  { case obj, with }
                end;   { ident }

     realcon: begin
                x.typ := reals; x.ref := 0;
                enterreal(rnum);
                emit1(25, c1);
                insymbol
              end;
     charcon: begin
                x.typ := chars; x.ref := 0; x.temp := false;
                emit1(24, inum);
                insymbol
              end;
      intcon: begin
                x.typ := ints; x.ref := 0;
                emit1(24, inum);
                insymbol
              end;
   stringcon: begin
                x.typ := strngs; x.ref := 0; x.temp := false;
                emit1(24,seg(spnt^));
                insymbol
              end;
     lparent: begin
                insymbol;
                expression(fsys+[rparent], x);
                if sy = rparent
                then insymbol
                else error(4)
              end;
       notsy: begin
                insymbol;
                factor(fsys,x);
                if x.typ=bools
                then emit(135)
                else if x.typ<>notyp
                     then error(32)
              end;
            end;  { case sy }
            test(fsys, facbegsys, 6);
            end { while }
          end { factor } ;

        begin { term }
          factor(fsys+[times,rdiv,idiv,imod,andsy], x);
          while sy in [times,rdiv,idiv,imod,andsy] do
          begin
            op := sy;
            insymbol;
            factor(fsys+[times,rdiv,idiv,imod,andsy], y);
            if op = times
            then begin
              x.typ := resulttype(x.typ, y.typ);

              case x.typ of
         notyp: ;
         ints : emit(157);
         reals: emit(160);
              end

            end else if op = rdiv
                     then begin
                       if x.typ = ints
                       then begin
                         emit1(26,1);
                         x.typ := reals
                       end ;
                       if y.typ = ints
                       then begin
                         emit1(26,0);
                         y.typ := reals
                       end ;
                       if (x.typ=reals) and (y.typ=reals)
                       then emit(161)
                       else begin
                         if (x.typ<>notyp) and (y.typ<>notyp)
                         then error(33);
                         x.typ := notyp
                       end
                     end else
                       if op = andsy
                       then begin
                         if (x.typ=bools) and (y.typ=bools)
                         then emit(156)
                         else begin
                           if (x.typ<>notyp) and (y.typ<>notyp)
                           then error(32);
                           x.typ := notyp
                         end
                       end else begin     { op in [idiv,imod] }
                         if (x.typ=ints) and (y.typ=ints)
                         then if op=idiv
                              then emit(158)
                              else emit(159)
                         else begin
                           if (x.typ<>notyp) and (y.typ<>notyp)
                           then error(34);
                           x.typ := notyp
                         end
                       end
          end {while}
        end { term } ;

      begin { simpleexpression }
        if sy in [plus,minus]
        then begin
          op := sy;
          insymbol;
          term(fsys+[plus,minus], x);
          if x.typ > reals
          then error(33)
          else if op = minus
               then if x.typ = reals
                    then emit(164)
                    else emit(136)
        end else term(fsys+[plus,minus,orsy], x);
        while sy in [plus,minus,orsy] do
        begin
          op := sy;
          insymbol;
          term(fsys+[plus,minus,orsy], y);
          if op = orsy
          then begin
            if (x.typ=bools) and (y.typ=bools)
            then emit(151)
            else begin
              if (x.typ <> notyp) and (y.typ<>notyp)
              then error(32);
              x.typ := notyp
            end
          end else if (x.typ = chars) or (x.typ = strngs)
          then begin
            if not((y.typ = chars) or (y.typ = strngs))
            then begin error(38);
                   x.typ := notyp; end
            else begin
                   if x.typ = chars then t := 0 else t := 1;
                   if y.typ = strngs then t := t+2;
                   if x.temp then t := t+4;
                   if y.temp then t := t+8;
                   emit1(7,t);
                   x.typ := strngs; x.temp := true;
                 end
            end
          else begin
            x.typ := resulttype(x.typ, y.typ);

            case x.typ of
       notyp: ;
       ints : if op = plus
              then emit(152)
              else emit(153);
       reals: if op = plus
              then emit(154)
              else emit(155)
            end {case}

          end
        end {while}
      end { simpleexpression } ;

    begin { expression }
      simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x);
      if sy in [eql,neq,lss,leq,gtr,geq]
      then begin
        op := sy;
        insymbol;
        simpleexpression(fsys, y);
        if (x.typ in [notyp,ints,bools,chars]) and (x.typ = y.typ)
        then case op of

             eql: emit(145);
             neq: emit(146);
             lss: emit(147);
             leq: emit(148);
             gtr: emit(149);
             geq: emit(150);

             end
        else begin
          if x.typ = ints
          then begin
            x.typ := reals;
            emit1(26,1)
          end else if y.typ = ints
                   then begin
                     y.typ := reals;
                     emit1(26,0)
                   end ;
          if (x.typ=reals) and (y.typ=reals)
          then case op of

               eql: emit(139);
               neq: emit(140);
               lss: emit(141);
               leq: emit(142);
               gtr: emit(143);
               geq: emit(144);

               end
          else if (x.typ in [chars,strngs]) and (y.typ in [chars,strngs])
               then begin
                 if x.typ=strngs then t := 1 else t := 0;
                 if y.typ=strngs then t := t+2;
                 if x.temp then t := t+4;
                 if y.temp then t := t+8;
                 if op in [eql,leq,geq] then t := t+16;
                 if op in [neq,gtr,geq] then t := t+32;
                 if op in [neq,lss,leq] then t := t+64;
                 emit1(32,t);
               end
               else error(35)
             end ;
             x.typ := bools
      end
 end { expression } ;

    procedure assignment(lv,ad: integer);

    var    x,y: item;
           f  : integer;
    begin              { tab[i].obj in [vvariable,funktion] }
      x.typ := tab[i].typ;
      x.ref := tab[i].ref;
      if tab[i].normal then f := 0 else f := 1;
      emit2(f, lv, ad);
      if sy in [lbrack,lparent,period]
      then if x.typ<>strngs
           then selector([becomes,eql]+fsys, x)
           else error(60);
      if sy = becomes
      then insymbol
      else begin
        error(51);
        if sy = eql then insymbol
      end ;

      expression(fsys, y);
      if x.typ = y.typ
      then if x.typ in stantyps
           then if x.typ=strngs
                then if y.temp then emit(166)
                               else emit(169)
                else emit(138)
           else if x.ref <> y.ref
                then error(46)
                else if x.typ = arrays
                     then emit1(23,atab[x.ref].size)
                     else emit1(23,btab[x.ref].vsize)
      else if (x.typ=reals) and (y.typ=ints)
      then begin
        emit1(26,0);
        emit(138) end
      else if (x.typ=chars) and (y.typ=strngs)
           then begin
                  if y.temp then t := 8 else t := 0;
                  emit1(31,t); end
      else if (x.typ=strngs) and (y.typ=chars)
           then emit(168)
      else if (x.typ=strngs) and (y.typ=arrays)
           then if atab[y.ref].eltyp = chars
                then begin emit1(167,atab[y.ref].size); emit(166) end
                else
      else if (x.typ=arrays) and (y.typ=strngs)
           then if atab[x.ref].eltyp = chars
                then if y.temp then emit1(175,atab[x.ref].size)
                               else emit1(174,atab[x.ref].size)
                else
      else if (x.typ<>notyp) and (y.typ<>notyp)
           then error(46)
    end { assignment } ;

    procedure compoundstatement;

    begin
      insymbol;
      statement([semicolon,endsy]+fsys);
      while sy in [semicolon]+statbegsys do
      begin
        if sy = semicolon
        then insymbol
        else error(14);
        statement([semicolon,endsy]+fsys)
      end ;
      if sy = endsy then insymbol else error(57)
    end { compoundstatement } ;

    procedure ifstatement;

    var    x: item;
           lc1,lc2: integer;
    begin
      insymbol;
      expression(fsys+[thensy,dosy], x);
      if not (x.typ in [bools,notyp])
      then error(17);
      lc1 := lc;
      emit(11);     { jmpc }

      if sy = thensy
      then insymbol
      else begin
        error(52);
        if sy = dosy
        then insymbol
      end ;

      statement(fsys+[elsesy]);

      if sy = elsesy
      then begin
        insymbol;                lc2 := lc;
        emit(10);        code[lc1].y := lc;
        statement(fsys); code[lc2].y := lc
      end
      else code[lc1].y := lc
    end { ifstatement } ;

    procedure casestatement;

    var    x: item;
    i,j,k,lc1: integer;
    casetab: array [1..csmax] of
              packed record
                val, lc: index
              end ;
    exittab: array [1..csmax] of integer;

      procedure caselabel;

      var    lab: conrec;
             k  : integer;
      begin
        constant(fsys+[comma,colon], lab);
        if lab.tp <> x.typ
        then error(47)
        else if i = csmax
             then fatal(6)
             else begin
               i := i+1;    k := 0;
               casetab[i].val :=lab.i;
               casetab[i].lc  := lc;
               repeat
                 k := k+1
               until casetab[k].val = lab.i;

               if k < i then error(1);   { multiple definition }
             end
      end { caselabel } ;

      procedure onecase;

      begin
        if sy in constbegsys
        then begin
          caselabel;
          while sy = comma do
          begin
            insymbol; caselabel
          end ;
          if sy = colon
          then insymbol else error(5);
          statement([semicolon,endsy]+fsys);
          j := j+1;
          exittab[j] := lc; emit(10)
        end
      end { onecase } ;

    begin {casestatement}
      insymbol;
      i := 0;   j := 0;
      expression(fsys+[ofsy,comma,colon], x);
      if not (x.typ in [ints,bools,chars,notyp])
      then error(23);
      lc1 := lc; emit(12);  { jmpx }

      if sy = ofsy then insymbol else error(8);
      onecase;
      while sy = semicolon do
      begin
        insymbol;
        onecase
      end ;
      code[lc1].y := lc;
      for k := 1 to i do
      begin
        emit1(13,casetab[k].val);
        emit1(13,casetab[k].lc)
      end ;
      emit1(10,0);
      for k := 1 to j do code[exittab[k]].y := lc;
      if sy = endsy then insymbol else error(57)
    end { casestatement } ;

    procedure repeatstatement;

    var    x  : item;
           lc1: integer;
    begin
      lc1 := lc;
      insymbol;
      statement([semicolon,untilsy]+fsys);
      while sy in [semicolon]+statbegsys do
      begin
        if sy = semicolon then insymbol else error(14);
        statement([semicolon,untilsy]+fsys)
      end ;
      if sy = untilsy
      then begin
        insymbol;
        expression(fsys, x);
        if not (x.typ in [bools,notyp]) then error(17);
        emit1(11, lc1)
      end else error(53)
    end { repeatstatement } ;

    procedure whilestatement;

    var    x: item;
           lc1,lc2: integer;
    begin
      insymbol;
      lc1 := lc;
      expression(fsys+[dosy], x);
      if not (x.typ in [bools,notyp]) then error(17);
      lc2 := lc; emit(11);

      if sy = dosy then insymbol else error(54);
      statement(fsys);
      emit1(10,lc1);
      code[lc2].y := lc
    end { whilestatement } ;

    procedure forstatement;

    var    cvt: types;
           x  : item;
           i,f,lc1,lc2: integer;
    begin
      insymbol;
      if sy = ident
      then begin
        i := loc(id);
        insymbol;
        if i = 0
        then cvt := ints
        else if tab[i].obj = vvariable
             then begin
               cvt := tab[i].typ;
               if tab[i].normal then f := 0 else f := 1;
               emit2(f, tab[i].lev, tab[i].adr);
               if not (cvt in [notyp,ints,bools,chars]) then error(18)
             end else begin
               error(37); cvt := ints
             end
      end else skip([becomes,tosy,downtosy,dosy]+fsys, 2);

      if sy = becomes
      then begin
        insymbol;
        expression([tosy,downtosy,dosy]+fsys, x);
        if x.typ <> cvt then error(19);
      end else skip([tosy,downtosy,dosy]+fsys, 51);
      f := 14;

      if sy in [tosy, downtosy]
      then begin
        if sy = downtosy then f := 16;
        insymbol;
        expression([dosy]+fsys, x);
        if x.typ <> cvt then error(19)
      end else skip([dosy]+fsys, 55);

      lc1 := lc; emit(f);
      if sy = dosy then insymbol else error(54);
      lc2 := lc;
      statement(fsys);
      emit1(f+1,lc2);
      code[lc1].y := lc
    end { forstatement } ;

    procedure standproc(n: integer);

    var    i,f: integer;
           x,y: item;
    begin

      case n of

 1,2: begin { read }
        if sy = lparent
        then begin
          repeat
            insymbol;
            if sy <> ident
            then error(2)
            else begin
              i := loc(id);
              insymbol;
              if i <> 0
              then if tab[i].obj <> vvariable
                   then error( 37)
                   else begin
                     x.typ := tab[i].typ;
                     x.ref := tab[i].ref;
                     if tab[i].normal then f := 0 else f := 1;
                     emit2(f, tab[i].lev, tab[i].adr);
                     if sy in [lbrack,lparent,period]
                     then begin
                            if x.typ=strngs then error(60);
                            selector(fsys+[comma,rparent], x); end;
                     if x.typ in [ints,reals,chars,strngs,notyp]
                     then emit1(27,ord(x.typ))
                     else error(41)
                   end
            end ;
            test([comma,rparent], fsys, 6);
          until sy <> comma;

          if sy = rparent then insymbol else error(4)
        end ;
        if n = 2 then emit(162)
      end ;
 3,4: begin { write }
        if sy = lparent
        then begin
          repeat
            insymbol;
            expression(fsys+[comma,colon,rparent], x);
            if not (x.typ in stantyps) then error(41);
            if sy = colon
            then begin
              insymbol;
              expression(fsys+[comma,colon,rparent], y);
              if y.typ <> ints then error(43);
              if sy = colon
              then begin
                if x.typ <> reals then error( 42);
                insymbol;
                expression(fsys+[comma,rparent], y);
                if y.typ <> ints then error(43);
                emit(137)
              end else begin
                if x.typ=strngs
                then if x.temp then emit(177) else emit(176)
                else emit1(30, ord(x.typ))
              end
            end else if x.typ=strngs
                     then if x.temp then emit(171)
                                    else emit(170)
                     else emit1(29, ord(x.typ))
          until sy <> comma;
          if sy = rparent then insymbol else error(4)
        end ;
        if n = 4 then emit(163)
      end ; {write}

   5: emit(131); { halt }

   6: emit1(8,43); { randomize }

   7: emit1(8,44); { clrscr }

   8: begin  { gotoxy }
        if sy = lparent then insymbol else error(9);
        expression(fsys+[comma,rparent], x);
        if x.typ<>ints then error(43);
        test([comma],fsys+[rparent],59);
        if sy = comma
        then begin
          insymbol;
          expression(fsys+[rparent], y);
          if y.typ<>ints then error(43);
          emit1(8,45);
        end;
        if sy = rparent then insymbol else error(4);
      end;

9,10,11,12:
      begin
        if sy = lparent then insymbol else error(9);
        expression(fsys+[rparent], x);
        if x.typ<>ints then error(43);
        case n of
       9: emit1(8,46);  { textcolor }
      10: emit1(8,50);  { delay }
      11: emit1(8,51);  { textbackground }
      12: emit1(8,52);  { sound }
        end;
        if sy = rparent then insymbol else error(4);
      end;

  13: emit1(8,53);  { nosound }

      end { case }
    end { standproc } ;

  begin { statement }
    if sy in statbegsys+[ident]
    then case sy of

       ident: begin
                i := loc(id);
                insymbol;
                if i <> 0
                then case tab[i].obj of

         konstant, type1: error(45);
               vvariable: assignment(tab[i].lev, tab[i].adr);
               prozedure: if tab[i].lev <> 0
                          then call(fsys, i)
                          else standproc(tab[i].adr);
                funktion: if tab[i].ref = display[level]
                          then assignment(tab[i].lev+1, 0)
                          else error(45)
                     end {case}

              end ;

     beginsy: compoundstatement;
        ifsy: ifstatement;
      casesy: casestatement;
     whilesy: whilestatement;
    repeatsy: repeatstatement;
       forsy: forstatement;

         end; {case}

    test(fsys, [], 14)
  end { statement } ;

begin { block }
  dx := 6; prt := t;
  if level > lmax then fatal(5);
  test([lparent,colon,semicolon], fsys, 14);

  enterblock;
           prb := b;      display[level] := b;
  tab[prt].typ := notyp;    tab[prt].ref := prb;
  if (sy = lparent) and (level > 1) then parameterlist;
  btab[prb].lastpar := t;btab[prb].psize := dx;

  if isfun
  then if sy = colon
       then begin
         insymbol;   { function type }
         if sy = ident
         then begin
           x := loc(id);
           insymbol;
           if x <> 0
           then if tab[x].obj <> type1
                then error(29)
                else if tab[x].typ in stantyps
                     then tab[prt].typ := tab[x].typ
                     else error(15)
         end else skip([semicolon]+fsys, 2)
       end else error(5);
  if sy = semicolon then insymbol else error(14);

  repeat
    if sy = constsy then constdec;
    if sy = typesy then typedeclaration;
    if sy = varsy then variabledeclaration;
    btab[prb].vsize := dx;
    while sy in [procsy,funcsy] do procdeclaration;
    test([beginsy], blockbegsys+statbegsys, 56)
  until sy in statbegsys;

  tab[prt].adr := lc;
  insymbol;
  statement([semicolon,endsy]+fsys);

  while sy in [semicolon]+statbegsys do
  begin
    if sy = semicolon then insymbol else error(14);
    statement([semicolon,endsy]+fsys)
  end ;
  if sy = endsy then insymbol else error(57);
  test(fsys+[period], [], 6)
end { block } ;